perm filename FILUP.F4[CMS,LCS] blob sn#100909 filedate 1974-05-06 generic text, type T, neo UTF8
00100	C  Q AND R  ARE X,Y COORDS.  NE(1)=WDCNT. OTHER NE'S HAVE 3
00200	C   FOR INVIS. VECTORS.   M=VERTICAL SCAN LINES
00300		SUBROUTINE FILLER(Q,R,NE,M,LP,IT)
00400		DIMENSION Q(1),R(1),NE(1)
00500		KK=NE(1)
00600		NX=-10000
00700		JN=NX
00800		KJ=2
00900		DO 4 K=2,KK
01000		IF(NE(K).NE.3)GO TO 11
01100		NE(K)=KJ
01200		KJ=K+1
01300		GO TO 4
01400	11	NE(K)=0
01500	4	CONTINUE
01600		DO 12 K=1,KK
01700		Q(K)=IFIX(Q(K))
01800	12	R(K)=IFIX(R(K))
01900		NE(KK+1)=KJ
02000	C  FINDS JUMPS
02100		DO 2 J=2,KK
02200		IF(NE(J).GT.0.OR.Q(J).EQ.Q(J-1))GO TO 2
02300	C  SKIPS VERTICAL LINES
02400		XMID=HALF(Q,J)+.00001
02500	C  MIDPOINT OF LINE
02600		ALT=HALF(R,J)
02700	C  THE ALTITUDE
02800		KJ=0
02900	
03000	100	DO 3 L=2,KK
03100		IF(L.EQ.J.OR.NE(L).GT.0)GO TO 3
03200	C  NEXT FINDS LINE OVERLAP
03300		IF(MISS(L,XMID,Q))GO TO 3
03400	C  NEXT FINDS ALT. OF CROSSING
03500	40	Y=HGHT(L,XMID,Q,R)
03600		IF(Y.LT.ALT)KJ=KJ+1
03700	3	CONTINUE
03800	
03900		IF(MOD(KJ,2).EQ.0)GO TO 2
04000	C  NEXT IF FOUND A LINE TO DRAW LINES DOWN FROM.
04100		NE(J)=-1
04200		KJ=M
04300		N=Q(J)
04400		L=Q(J-1)
04500	CC	IF(IABS(N-L).LE.M)GO TO 2
04600	C  SKIPS SEGS SHORTER THAN M INCREMENT.
04700		ALT=.0001
04800		IF(N.GT.L)GO TO 33
04900		KJ=-KJ
05000		ALT=-ALT
05100	33	IF(L.EQ.NX.AND.JN.EQ.J-1)GO TO 17
05200		JA=3
05300		X=-1
05400	17	NX=N
05500		JN=J
05600	
05700	CC34	L=L+KJ/2
05800		DO 6 K=L,N,KJ
05900		RK=K
06000		XK=RK
06100		IF(K.EQ.N)ALT=-ALT
06200	C  NO SHIFT AT LAST POSITION
06300	 	RK=RK+ALT
06400		Y=HGHT(J,RK,Q,R)
06500	CC1000	YK=Y-1
06600		IF(X)CALL LINES(XK,Y,JA,LP,IT)
06700		JA=2
06800		H=-10000
06900	
07000	18	DO 7 I=2,KK
07100		IF(NE(I).NE.0)GO TO 7
07200	C  SKIP IF SAME LINE.
07300		IF(MISS(I,RK,Q))GO TO 7
07400	C  TRY NEXT POINT IF IT HIT A -1 LINE.
07500	9	B=HGHT(I,RK,Q,R)
07600		IF(B.GT.Y)GO TO 7
07700		IF(B.LE.H)GO TO 7
07800		H=B
07900		IX=I
08000	C  FOUND HIGHEST NEW POINT
08100	7	CONTINUE
08200		IF(H.EQ.Y)GO TO 31
08300	C  WIPES OUT THIS LINE SEG.
08400		IF(H.NE.-10000)GO TO 31
08500		NX=-10000
08600	C***	X=1
08700		X=-1
08800		GO TO 6
08900	31	IF(IX.NE.JX.AND.X.GT.0)JA=3
09000		JX=IX
09100		CALL LINES(XK,H,JA,LP,IT)
09200		JA=2
09300		IF(X.GT.0)CALL LINES(XK,Y,JA,LP,IT)
09400		X=-X
09500	600	GO TO 6
09600	6	CONTINUE
09700	2	CONTINUE
09800		RETURN
09900		END
10000		
10100		FUNCTION HGHT(J,A,Q,R)
10200		DIMENSION Q(1),R(1)
10300		B=R(J-1)
10400		D=Q(J-1)
10500		F=Q(J)
10600		HGHT=((R(J)-B)*(A-D))/(F-D)+B
10700		IF(F.EQ.D)HGHT=B
10800		RETURN
10900		END
11000	
11100		FUNCTION MISS(J,A,Q)
11200		DIMENSION Q(1)
11300		B=Q(J)
11400		C=Q(J-1)
11500		MISS=-1
11600		IF((A.LT.C.AND.A.GT.B).OR.(A.LT.B.AND.A.GT.C))MISS=0
11700		RETURN
11800		END
11900	C  MISS=-1, HIT=0
12000	
12100		FUNCTION HALF(A,J)
12200		DIMENSION A(1)
12300		HALF=(A(J-1)-A(J))/2.+A(J)
12400		RETURN
12500		END
12600	
12700		SUBROUTINE LINES(A,B,J,I,IT)
12800		M=A
12900		N=B
13000		IF(IT.LT.11)GO TO 11
13100		M=B
13200		N=A
13300	11	IF(.NOT.I)GO TO 2
13400		IF(J.EQ.3)GO TO 1
13500		CALL AVECT(M,N)
13600		RETURN
13700	1	CALL AIVECT(M,N)
13800		RETURN
13900	2	CALL PLOT(M,N,J)
14000		RETURN
14100		END